home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_Tix.idb / usr / freeware / lib / tix4.1 / Utils.tcl.z / Utils.tcl
Encoding:
Text File  |  1999-01-26  |  11.1 KB  |  499 lines
  1. # Util.tcl --
  2. #
  3. #    The Tix utility commands. Some of these commands are
  4. #    replacement of or extensions to the existing TK
  5. #    commands. Occasionaly, you have to use the commands inside
  6. #    this file instead of thestandard TK commands to make your
  7. #    applicatiion work better with Tix. Please read the
  8. #    documentations (programmer's guide, man pages) for information
  9. #    about these utility commands.
  10. #
  11. # Copyright (c) 1996, Expert Interface Technologies
  12. #
  13. # See the file "license.terms" for information on usage and redistribution
  14. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15. #
  16.  
  17.  
  18. #
  19. # kludge: should be able to handle all kinds of flags
  20. #         now only handles "-flag value" pairs.
  21. #
  22. proc tixHandleArgv {p_argv p_options validFlags} {
  23.     upvar $p_options opt
  24.     upvar $p_argv    argv
  25.  
  26.     set old_argv $argv
  27.     set argv ""
  28.  
  29.     tixForEach {flag value} $old_argv {
  30.     if {[lsearch $validFlags $flag] != "-1"} {
  31.         # The caller will handle this option exclusively
  32.         # It won't be added back to the original arglist
  33.         #
  34.         eval $opt($flag,action) $value
  35.     } else {
  36.         # The caller does not handle this option
  37.         #
  38.         lappend argv $flag
  39.         lappend argv $value
  40.     }
  41.     }
  42. }
  43.  
  44. #-----------------------------------------------------------------------
  45. # tixDisableAll -
  46. #
  47. #     Disable all members in a sub widget tree
  48. #
  49. proc tixDisableAll {w} {
  50.     foreach x [tixDescendants $w] {
  51.     catch {$x config -state disabled}
  52.     }
  53. }
  54.  
  55. #----------------------------------------------------------------------
  56. # tixEnableAll -
  57. #
  58. #     enable all members in a sub widget tree
  59. #
  60. proc tixEnableAll {w} {
  61.     foreach x [tixDescendants $w] {
  62.     catch {$x config -state normal}
  63.     }
  64. }
  65.  
  66. #----------------------------------------------------------------------
  67. # tixDescendants -
  68. #
  69. #    Return a list of all the member of a widget subtree, including
  70. # the tree's root widget.
  71. #
  72. proc tixDescendants {parent} {
  73.     set des ""
  74.     lappend des $parent
  75.  
  76.     foreach w [winfo children $parent] {
  77.     foreach x [tixDescendants $w] {
  78.         lappend des $x
  79.     }
  80.     }
  81.     return $des
  82. }
  83.  
  84.  
  85. #----------------------------------------------------------------------
  86. # tixForEach -
  87. #
  88. #     Extension of foreach, can handle more than one names
  89. #
  90. #
  91. proc tixForEach {names list body} {
  92.     set len [llength $list]
  93.     set i 0
  94.  
  95.     while {$i < $len} {
  96.     foreach name $names {
  97.         uplevel 1 [list set $name [lindex $list $i]]
  98.         incr i
  99.     }
  100.  
  101.     if {$i > $len} {
  102.         error "incorrect number of items in the list \{$list\}"
  103.     }
  104.  
  105.     uplevel 1 $body
  106.     }
  107. }
  108.  
  109. #----------------------------------------------------------------------
  110. # tixTopLevel -
  111. #
  112. #    Create a toplevel widget and unmap it immediately. This will ensure
  113. # that this toplevel widgets will not be popped up prematurely when you
  114. # create Tix widgets inside it.
  115. #
  116. #    "tixTopLevel" also provide options for you to specify the appearance
  117. # and behavior of this toplevel.
  118. #
  119. #
  120. #
  121. proc tixTopLevel {w args} {
  122.     set opt (-geometry) ""
  123.     set opt (-minsize)  ""
  124.     set opt (-maxsize)  ""
  125.     set opt (-width)    ""
  126.     set opt (-height)   ""
  127.  
  128.     eval toplevel $w $args
  129.     wm withdraw $w
  130. }
  131.  
  132. # This is a big kludge
  133. #
  134. #    Substitutes all [...] and $.. in the string in $args
  135. #
  136. proc tixInt_Expand {args} {
  137.     return $args
  138. }
  139.  
  140. # Print out all the config options of a widget
  141. #
  142. proc tixPConfig {w} {
  143.     foreach opt [lsort [$w config]] {
  144.     puts $opt
  145.     }
  146. }
  147.  
  148. proc tixAppendBindTag {w tag} {
  149.     bindtags $w [concat [bindtags $w] $tag]
  150. }
  151.  
  152. proc tixAddBindTag {w tag} {
  153.     bindtags $w [concat $tag [bindtags $w] ]
  154. }
  155.  
  156. proc tixSubwidgetRef {sub} {
  157.     global tixSRef
  158.  
  159.     return $tixSRef($sub)
  160. }
  161.  
  162. proc tixSubwidgetRetCreate {sub ref} {
  163.     global tixSRef
  164.  
  165.     set tixSRef($sub) $ref
  166. }
  167.  
  168. proc tixSubwidgetRetDelete {sub} {
  169.     global tixSRef
  170.  
  171.     catch {unset tixSRef($sub)}
  172. }
  173.  
  174. proc tixListboxGetCurrent {listbox} {
  175.     return [tixEvent flag V]
  176. }
  177.  
  178.  
  179. # tixSetMegaWidget --
  180. #
  181. #    Associate a subwidget with its mega widget "owner". This is mainly
  182. #    used when we add a new bindtag to a subwidget and we need to find out
  183. #    the name of the mega widget inside the binding.
  184. #
  185. proc tixSetMegaWidget {w mega {type any}} {
  186.     global tixMega
  187.  
  188.     set tixMega($type,$w) $mega
  189. }
  190.  
  191. proc tixGetMegaWidget {w {type any}} {
  192.     global tixMega
  193.  
  194.     return $tixMega($type,$w)
  195. }
  196.  
  197. proc tixUnsetMegaWidget {w} {
  198.     global tixMega
  199.  
  200.     if [info exists tixMega($w)] {
  201.     unset tixMega($w)
  202.     }
  203. }
  204.  
  205. # tixBusy : display busy cursors on a window
  206. #
  207. #
  208. # Should flush the event queue (but not do any idle tasks) before blocking
  209. # the target window (I am not sure if it is aready doing so )
  210. #
  211. # ToDo: should take some additional windows to raise
  212. #
  213. proc tixBusy {w flag {focuswin ""}} {
  214.  
  215.     if {[info command tixInputOnly] == ""} {
  216.     return
  217.     }
  218.  
  219.     global tixBusy
  220.     set toplevel [winfo toplevel $w]
  221.  
  222.     if {![info exists tixBusy(cursor)]} {
  223.     set tixBusy(cursor) watch
  224. #    set tixBusy(cursor) "[tix getbitmap hourglass] \
  225. #        [string range [tix getbitmap hourglass.mask] 1 end]\
  226. #         black white"
  227.     }
  228.  
  229.     if {$toplevel == "."} {
  230.     set inputonly0 .__tix__busy0
  231.     set inputonly1 .__tix__busy1
  232.     set inputonly2 .__tix__busy2
  233.     set inputonly3 .__tix__busy3
  234.     } else {
  235.     set inputonly0 $toplevel.__tix__busy0
  236.     set inputonly1 $toplevel.__tix__busy1
  237.     set inputonly2 $toplevel.__tix__busy2
  238.     set inputonly3 $toplevel.__tix__busy3
  239.     }
  240.  
  241.     if {![winfo exists $inputonly0]} {
  242.     for {set i 0} {$i < 4} {incr i} {
  243.         tixInputOnly [set inputonly$i] -cursor $tixBusy(cursor)
  244.     }
  245.     }
  246.  
  247.     case $flag {
  248.     on {
  249.         if {$focuswin != "" && [winfo id $focuswin] != 0} {
  250.         if [info exists tixBusy($focuswin,oldcursor)] {
  251.             return
  252.         }
  253.         set tixBusy($focuswin,oldcursor) [$focuswin cget -cursor]
  254.         $focuswin config -cursor $tixBusy(cursor)
  255.  
  256.         set x1 [expr [winfo rootx $focuswin]-[winfo rootx $toplevel]]
  257.         set y1 [expr [winfo rooty $focuswin]-[winfo rooty $toplevel]]
  258.  
  259.         set W  [winfo width $focuswin]
  260.         set H  [winfo height $focuswin]
  261.         set x2 [expr $x1 + $W]
  262.         set y2 [expr $y1 + $H]
  263.  
  264.  
  265.         if {$y1 > 0} {
  266.             tixMoveResizeWindow $inputonly0 0   0   10000 $y1
  267.         }
  268.         if {$x1 > 0} {
  269.             tixMoveResizeWindow $inputonly1 0   0   $x1   10000
  270.         }
  271.         tixMoveResizeWindow $inputonly2 0   $y2 10000 10000
  272.         tixMoveResizeWindow $inputonly3 $x2 0   10000 10000
  273.  
  274.         for {set i 0} {$i < 4} {incr i} {
  275.             tixMapWindow [set inputonly$i] 
  276.             tixRaiseWindow [set inputonly$i]
  277.         }
  278.         tixFlushX $w
  279.         } else {
  280.         tixMoveResizeWindow $inputonly0 0 0 10000 10000
  281.         tixMapWindow $inputonly0
  282.         tixRaiseWindow $inputonly0
  283.         }
  284.     }
  285.     off {
  286.         tixUnmapWindow $inputonly0
  287.         tixUnmapWindow $inputonly1
  288.         tixUnmapWindow $inputonly2
  289.         tixUnmapWindow $inputonly3
  290.  
  291.         if {$focuswin != "" && [winfo id $focuswin] != 0} {
  292.         if [info exists tixBusy($focuswin,oldcursor)] {
  293.             $focuswin config -cursor $tixBusy($focuswin,oldcursor)
  294.             if [info exists tixBusy($focuswin,oldcursor)] {
  295.             unset tixBusy($focuswin,oldcursor)
  296.             }
  297.         }
  298.         }
  299.     }
  300.     }
  301.    
  302. }
  303.  
  304. proc tixOptionName {w} {
  305.     return [string range $w 1 [expr [string length $w]-1]]
  306. }
  307.  
  308. proc tixSetSilent {chooser value} {
  309.     $chooser config -disablecallback true
  310.     $chooser config -value $value
  311.     $chooser config -disablecallback false
  312. }
  313.  
  314. proc tixSetChooser {chooser value} {
  315.  
  316.     puts "obsolete command tixSetChooser, call tixSetSilent instead"
  317.  
  318.     $chooser config -disablecallback true
  319.     $chooser config -value $value
  320.     $chooser config -disablecallback false
  321. }
  322.  
  323. # This command is useful if you want to ingore the arguments
  324. # passed by the -command or -browsecmd options of the Tix widgets. E.g
  325. #
  326. # tixFileSelectDialog .c -command "puts foo; tixBreak"
  327. #
  328. #
  329. proc tixBreak {args} {}
  330.  
  331. #----------------------------------------------------------------------
  332. # tixDestroy -- deletes a Tix class object (not widget classes)
  333. #----------------------------------------------------------------------
  334. proc tixDestroy {w} {
  335.     upvar #0 $w data
  336.     
  337.     set destructor ""
  338.     if [info exists data(className)] {
  339.     catch {
  340.         set destructor [tixGetMethod $w $data(className) Destructor]
  341.     }
  342.     }
  343.     if {$destructor != ""} {
  344.     $destructor $w
  345.     }
  346.     catch {
  347.     rename $w ""
  348.     }
  349.     catch {
  350.     unset data
  351.     }
  352.     return ""
  353. }
  354.  
  355. proc tixPushGrab {args} {
  356.     global tix_priv
  357.  
  358.     if {![info exists tix_priv(grab-list)]} {
  359.     set tix_priv(grab-list)    ""
  360.     set tix_priv(grab-mode)    ""
  361.     set tix_priv(grab-nopush) ""
  362.     }
  363.  
  364.     case [llength $args] {
  365.     1 {
  366.         set opt ""
  367.         set w [lindex $args 0]
  368.     }
  369.     2 {
  370.         set opt [lindex $args 0]
  371.         set w [lindex $args 1]
  372.     }
  373.     default {
  374.         error "wrong #of arguments: tixPushGrab ?-global? window"
  375.     }
  376.     }
  377.  
  378.     # Not everyone will call tixPushGrab. If someone else has a grab already
  379.     # save that one as well, so that we can restore that later
  380.     #
  381.     set last [lindex $tix_priv(grab-list) end]
  382.     set current [grab current $w]
  383.  
  384.     if {$current != "" && $current != $last} {
  385.     # Someone called "grab" directly
  386.     #
  387.     lappend tix_priv(grab-list)    $current
  388.     lappend tix_priv(grab-mode)    [grab status $current]
  389.     lappend tix_priv(grab-nopush) 1
  390.     }
  391.  
  392.     # Now push myself into the stack
  393.     #
  394.     lappend tix_priv(grab-list)    $w
  395.     lappend tix_priv(grab-mode)    $opt
  396.     lappend tix_priv(grab-nopush) 0
  397.  
  398.     if {$opt == "-global"} {
  399.     grab -global $w
  400.     } else {
  401.     grab $w
  402.     }
  403. }
  404.  
  405. proc tixPopGrab {} {
  406.     global tix_priv
  407.  
  408.     if {![info exists tix_priv(grab-list)]} {
  409.     set tix_priv(grab-list)   ""
  410.     set tix_priv(grab-mode)   ""
  411.     set tix_priv(grab-nopush) ""
  412.     }
  413.  
  414.     set len [llength $tix_priv(grab-list)]
  415.     if {$len <= 0} {
  416.     error "no window is grabbed by tixGrab"
  417.     }
  418.  
  419.     set w [lindex $tix_priv(grab-list) end]
  420.     grab release $w
  421.  
  422.     if {$len > 1} {
  423.     set tix_priv(grab-list)   \
  424.         [lrange $tix_priv(grab-list) 0 [expr $len-2]]
  425.     set tix_priv(grab-mode)   \
  426.         [lrange $tix_priv(grab-mode) 0 [expr $len-2]]
  427.     set tix_priv(grab-nopush) \
  428.         [lrange $tix_priv(grab-nopush) 0 [expr $len-2]]
  429.  
  430.     set w  [lindex $tix_priv(grab-list) end]
  431.     set m  [lindex $tix_priv(grab-list) end]
  432.     set np [lindex $tix_priv(grab-nopush) end]
  433.  
  434.     if {$np == 1} {
  435.         # We have a grab set by "grab"
  436.         #
  437.         set len [llength $tix_priv(grab-list)]
  438.  
  439.         if {$len > 1} {
  440.         set tix_priv(grab-list)   \
  441.             [lrange $tix_priv(grab-list) 0 [expr $len-2]]
  442.         set tix_priv(grab-mode)   \
  443.             [lrange $tix_priv(grab-mode) 0 [expr $len-2]]
  444.         set tix_priv(grab-nopush) \
  445.             [lrange $tix_priv(grab-nopush) 0 [expr $len-2]]
  446.         } else {
  447.         set tix_priv(grab-list)   ""
  448.         set tix_priv(grab-mode)   ""
  449.         set tix_priv(grab-nopush) ""
  450.         }
  451.     }
  452.  
  453.     if {$m == "-global"} {
  454.         grab -global $w
  455.     } else {
  456.         grab $w
  457.     }
  458.     } else {
  459.       set tix_priv(grab-list)   ""
  460.     set tix_priv(grab-mode)   ""
  461.     set tix_priv(grab-nopush) ""
  462.     }
  463. }
  464.  
  465. proc tixWithinWindow {wid rootX rootY} {
  466.     set rx1 [winfo rootx $wid]
  467.     set ry1 [winfo rooty $wid]
  468.     set rw  [winfo width  $wid]
  469.     set rh  [winfo height $wid]
  470.     set rx2 [expr $rx1+$rw]
  471.     set ry2 [expr $ry1+$rh]
  472.  
  473.     if {$rootX >= $rx1 && $rootX < $rx2 && $rootY >= $ry1 && $rootY < $ry2} {
  474.     return 1
  475.     } else {
  476.     return 0
  477.     }
  478. }
  479.  
  480. proc tixWinWidth {w} {
  481.     set W [winfo width $w]
  482.     set bd [expr [$w cget -bd] + [$w cget -highlightthickness]]
  483.  
  484.     return [expr $W - 2*$bd]
  485. }
  486.  
  487. proc tixWinHeight {w} {
  488.     set H [winfo height $w]
  489.     set bd [expr [$w cget -bd] + [$w cget -highlightthickness]]
  490.  
  491.     return [expr $H - 2*$bd]
  492. }
  493.  
  494. # junk?
  495. #
  496. proc tixWinCmd {w} {
  497.     return [winfo command $w]
  498. }
  499.